unit PtSingletons;

interface

uses
  SysUtils, PtContainers;

type
  TSingletonObject = class(TInterfacedObject)
  protected
    function GetTypeID: integer; virtual; abstract;
    function GetObjID: integer; virtual; abstract;
  public
    procedure AfterConstruction; override;
    procedure BeforeDestruction; override;
  end;

  ISingletonFactory = interface
    procedure RegisterObject(obj: TSingletonObject);
    procedure UnregisterObject(obj: TSingletonObject);
  end;

  ESingleton = class(Exception)
  end;

var
  SingletonFactory: ISingletonFactory;

type
  TSingletonFactory = class(TInterfacedObject, ISingletonFactory)
  private
    fTypes: TIntegerSet;
    function  ObjToStr(obj: TSingletonObject): string;
    //  ISingletonFactory
    procedure RegisterObject(obj: TSingletonObject);
    procedure UnregisterObject(obj: TSingletonObject);
  public
    constructor Create;
    destructor  Destroy; override;
  end;

implementation

{ TSingletonObject }

procedure TSingletonObject.AfterConstruction;
begin
  inherited;
  SingletonFactory.RegisterObject(Self);
end;

procedure TSingletonObject.BeforeDestruction;
begin
  SingletonFactory.UnregisterObject(Self);
  inherited;
end;

{ TSingletonFactory }

constructor TSingletonFactory.Create;
begin
  inherited;
  fTypes  := TIntegerSet.Create;
end;

destructor TSingletonFactory.Destroy;
begin
  fTypes.Free;
  inherited;
end;

function TSingletonFactory.ObjToStr(obj: TSingletonObject): string;
begin
  Result  := IntToStr(obj.GetTypeID)+':'+IntToStr(obj.GetObjID);
end;

procedure TSingletonFactory.RegisterObject(obj: TSingletonObject);
var
  i : Integer;
  objs : TIntegerSet;
begin
  // Get object container
  i := fTypes.IndexOf(obj.GetTypeID);
  if  i < 0 then
    begin
      objs  := TIntegerSet.Create;
      fTypes.AddObject(obj.GetTypeID, objs);
    end
  else
    objs  := TIntegerSet(fTypes.Objects[i]);
  // Insert object
  i := objs.IndexOf(obj.GetObjID);
  if  i < 0 then
    objs.AddObject(obj.GetObjID, obj)
  else
    raise ESingleton.Create('Object '+ObjToStr(obj)+' is already registered.');
end;

procedure TSingletonFactory.UnregisterObject(obj: TSingletonObject);
var
  i : Integer;
  objs : TIntegerSet;
begin
  // Get object container
  i := fTypes.IndexOf(obj.GetTypeID);
  if  i < 0 then
    raise ESingleton.Create('Object type '+IntToStr(obj.GetTypeID)+' is not registered');
  objs  := TIntegerSet(fTypes.Objects[i]);
  // Remove object
  i := objs.IndexOf(obj.GetObjID);
  if  i < 0 then
    raise ESingleton.Create('Object '+ObjToStr(obj)+' is not registered');
  objs.Delete(i);
end;

end.
